
use MIME::WordDecoder;

use vars qw($DEBUG $tempdir %knownmailer %knownsubjects $parser);





#--------------------------------------------------------

    print "MIME type is ", $msg->head->mime_type, "\n" if $DEBUG;
    if ($msg->mime_type eq "multipart/report") {
	$classification = process_report($msg);
    } else { # not a nice report - do something else
	$classification = process_something_else($msg);
    }

	 


sub process_report {
    my $msg = shift;
    my $reporttype = $msg->head->mime_attr("content-type.report-type");
    if ("\L$reporttype" eq "delivery-status") {
	return process_delivery_status($msg);
    } else {
	print "ERR:Multipart/report report-type $reporttype unknown\n";
	return undef;
    }
}

sub process_delivery_status {
    my $msg = shift;
    my ($report, $body, $globals, $thisrecip, $reporthost);

    $report = $msg->parts(1); # Second part
    print "Type of part 2 is ", $report->mime_type, "\n" if $DEBUG;
    if ($report->mime_type eq "message/delivery-status") {
	my($n, $prevaction, $prevstatus, $line, @lines, $action, $status);
	my ($recipname, $fromuser);
	# We've got one! What do we do now?
	my $body = $report->bodyhandle;
	$body->print(\*STDOUT) if $DEBUG;
	# Take advantage of the fact that this looks like 822 headers...
	$globals = new Mail::Header;
	$globals->modify(0);
	@lines = $body->as_lines();
	while ($#lines >= 0 && ($line = shift @lines) ne "\n") {
	    chop $line;
	    print "Global: $line\n" if $DEBUG;
	    $globals->add(undef, $line);
	    $reporthost = $globals->get("reporting-mta");
	}
	$n = 0;
	$prevaction = "";
	$prevstatus = "";
	while ($#lines >= 0) {
	    ++ $n;
	    $thisrecip = new Mail::Header;
	    $thisrecip->modify(0);
	    while ($#lines >= 0 && ($line = shift @lines) ne "\n") {
		chop $line;
		print "Recip $n: $line\n" if $DEBUG;
		if ($line !~ /^\S+:/) {
		    warn "Erroneous line: $line\n";
		} else {
		    $thisrecip->add(undef, $line);
		}
	    }
	    $action = $thisrecip->get("action");
	    $status = $thisrecip->get("status");
	    $recipname = $thisrecip->get("final-recipient");
	    $action =~ tr/\r\n//d;
	    $status =~ tr/\r\n//d;
	    $recipname  =~ tr/\r\n//d;
	    print "$recipname: $action $status at $reporthost\n";
	    if ($prevaction ne "" && $action ne $prevaction) {
		print "ERR: Multiple action message\n";
		return undef;
	    } else {
		$prevaction = $action;
	    }
	    if ($prevstatus ne "" && $status ne $prevstatus) {
		print "ERR: Multiple status message\n";
		return undef;
	    } else {
		$prevstatus = $status;
	    }
	}
	print "Reported on $n recipient", $n>1?"s\n":"\n";
	# If we get here, there is only 1 action & status, so we
	# can take action on that. Mixed-mode messages go BOINK
	# at the moment.
	if ("\L$action" eq "delayed") {
	    return "warning";
	} elsif ("\L$action" eq "failed") {
	    if ($status =~ /^4\./) {
		return "tempfail";
	    } elsif ($status =~ /^5\./) {
		return "permfail";
	    } else {
		print "ERR: Not understood: status $status\n";
		return undef;
	    }
	} else {
	    print "ERR: Not understood: action $action\n";
	}
    } else {
	print "ERR: not a message/delivery-status\n";
    }
    return undef;
}

#----------------------------------------------------------------------
# Ad-hoc processing
#--------------------------------------------------------------------

sub process_something_else {
    my $msg = shift;
    my $from = $msg->head->get("from");
    my $subject = unmime($msg->head->get("subject"));
    my $result;
    my ($fromuser);
    $subject =~ tr/\r\n//d;
    print "Subject: $subject\n";
    print "From: $from\n";
    if ($from =~ /([.0-9A-Za-z-]+)@/) {
	$fromuser = $1;
    }
    if ($knownmailer{$fromuser}) {
	# We think this came from a mailer daemon
	if ($knownsubjects{$subject}) {
	    $result = $knownsubjects{$subject};
	    if ($result =~ /^lookatbody */) {
		$result = process_body($msg, $');
		return $result;
	    } else {
		return $result;
	    }
	} elsif ($subject =~ /\S+\@\S+$/) {
	    # try replacing a mail name at EOL with @
	    # This is for MIXER style gateways
	    $subject =~ s/\S+\@\S+$/\@/;
	    if ($knownsubjects{$subject}) {
		$result = $knownsubjects{$subject};
		if ($result =~ /^lookatbody */) {
		    $result = process_body($msg, $');
		    return $result;
		} else {
		    return $result;
		}
	    }
	} elsif ($subject =~ /\s+\(.*\)$/) {
	    # try replacing a parenthesized comment with (*)
	    $subject =~ s/\(.*\)$/(*)/;
	    if ($knownsubjects{$subject}) {
		$result = $knownsubjects{$subject};
		if ($result =~ /^lookatbody */) {
		    $result = process_body($msg, $');
		    return $result;
		} else {
		    return $result;
		}
	    }
	} elsif ($subject =~ /^Undeliverable: /) {
	    # exchange reflects the message subject
	    $result = process_body($msg, "exchange");
	    return $result;
	} elsif ($subject =~ /^Warning: /) {
	    return "warning";
	} else {
	    print "ERR: $fromuser is a mailer, but \"$subject\" is not known\n";
	}
    } else {
	print "HMMM: We don't think $fromuser is a mailer\n";
	return "message";
    }
    return undef;
}

sub process_body {
    my $msg = shift;
    my $hint = shift;

    if ($msg->mime_type eq "multipart/mixed") {
	print "Multipart nonstd report, look at 1st part\n";
	$msg = $msg->parts(0);
    }
    if ($msg->mime_type ne "text/plain") {
	print "ERR: Type is ", $msg->mime_type, ", not a text/plain\n";
	return undef;
    }
    my @lines = $msg->bodyhandle->as_lines;
    chomp @lines; # remove trailing NLs
    print "Hint is $hint\n";
    my $result = undef;
    if ($hint eq "smail") {
	$result = process_smail(@lines);
    } elsif ($hint eq "post.office") {
	$result = process_post_office(@lines);
    } elsif ($hint eq "vmailer") {
	$result = process_vmailer(@lines);
    } elsif ($hint eq "exchange") {
	$result = process_exchange(@lines);
    } elsif ($hint eq "compuserve") {
	$result = process_compuserve(@lines);
    } elsif ($hint eq "mixer") {
	return "permfail"; # dirty!
    }
    return $result;
}

sub process_smail {
    my @lines = @_;
    my $smailpattern = <<'EoF';
|------------------------- Message log follows: -------------------------|
 no valid recipients were found for this message
|------------------------- Failed addresses follow: ---------------------|
/(\S+ ... unknown user)|(\S+ ... unknown host)/*
|------------------------- Message text follows: ------------------------|
EoF

    my $result = pattern_lines("permfail", $smailpattern, @lines);
    if (defined($result)) {
	print "Matches an smail bounce\n";
	return $result;
    }

    $smailpattern = <<'EoF';
|------------------------- Failed addresses follow: ---------------------|
/\S+ ... loop detection: maximum hop count exceeded/*
|------------------------- Message text follows: ------------------------|
EoF
    $result = pattern_lines("tempfail", $smailpattern, @lines);
    if (defined($result)) {
	print "Matches an smail loop\n";
	return $result;
    }
    return undef; # if we got here
}

# Match a pattern (multiline string) to a sequence of lines
sub pattern_lines {
    my ($result, $smailpattern, @lines) = @_;
    my @smaillines;
    my $line;
    my $pat;
    @smaillines = split("\n", $smailpattern);
    my $matchedlines = 0;
    $line = shift(@lines);
    $line =~ s/[\r\n]*$//;
    for $pat (@smaillines) {
	if ($pat =~ /^\//) {
	    # pattern match
	    if ($pat =~ /\/\*$/) {
		# may occur zero or more times
		chop $pat;
		while (1) {
		    my $res = eval "\$line =~ $pat";
		    if ($@) {
			print "Eval $pat failed: $@\n";
			return undef;
		    }
		    last if (!$res);
		    $line = shift(@lines);
		}
	    } else {
		my $res = eval "\$line =~ $pat";
		if ($@) {
		    print "Eval $pat failed: $@\n";
		    return undef;
		}
		if (!$res) {
		    print "No match (pattern):\n";
		    print "Line($matchedlines): $line\n";
		    print "Pattern: $pat\n";
		    return undef;
		}
		$line = shift(@lines);
	    }
	} else {
	    $pat =~ s/(\W)/\\$1/g if $pat !~ /^\//;
	    if ($line !~ /$pat/ && $line ne $pat) {
 		print "No match:\n";
		print "Line($matchedlines): >$line<\n";
		print "Pattern: >$pat<\n";
		return undef;
	    }
	    $line = shift(@lines);
	    ++ $matchedlines;
	}
    }
    # if we got here, everything matched
    return $result;
}

sub process_post_office {
# A more primitive matching algorithm...

    my @lines = @_;
    my @grep = grep(/^No storage space available in mailbox for /, @lines);
    if ($#grep > -1) {
	print "Matches a post.office mailbox full\n";
	return "tempfail";
    } elsif (grep(/^The following destination addresses were unknown/, @lines) > 0) {
	print "Matches a post.office bounce\n";
	return "permfail";
    }
}

sub process_vmailer {
# this sub matches both Vmailer and some Postfix stuff
    my @lines = @_;
    my $smailpattern = <<'EoF';
/This is the VMailer program at host \S+./

I'm sorry to have to inform you that the message returned
below could not be delivered to one or more destinations.

/For further assistance, please contact <\S+>/

If you do so, please include this problem report. You can
delete your own text from the message returned below.

                        The VMailer program

        --- Delivery error report follows ---

/<\S+>: unknown user: "\S+"/

        --- Undelivered message follows ---
EoF

    my $result = pattern_lines("permfail", $smailpattern, @lines);
    if (defined($result)) {
	print "Matches a vmailer bounce\n";
	return $result;
    }
    $smailpattern = <<'EoF';
/This is the Postfix program at host \S+./

I'm sorry to have to inform you that the message returned
below could not be delivered to one or more destinations.

/For further assistance, please contact <\S+>/

If you do so, please include this problem report. You can
delete your own text from the message returned below.

/\s+The Postfix program/

/<\S+>: (unknown user: "\S+"|host \S+ said: )/
EoF

    $result = pattern_lines("permfail", $smailpattern, @lines);
    if (defined($result)) {
	print "Matches a Postfix bounce\n";
	return $result;
    }
    return undef; # if we got here
}

sub process_exchange {
    my @lines = @_;
    my $smailpattern = <<'EoF';
Your message

/  To:      \S+/
/  Subject: \S+/
/  Sent:    .*/

did not reach the following recipient(s):

/\S+ on .*/
/    (The recipient name is not recognized|The recipient was unavailable)/
EoF

    my $result = pattern_lines("permfail", $smailpattern, @lines);
    if (defined($result)) {
	print "Matches an Exchange bounce - $result\n";
	return $result;
    }
    return undef; # if we got here
}

sub process_compuserve {
    my @lines = @_;
    if ($lines[0] =~ /^Receiver not found: /) {
	return "permfail";
    } else {
	return undef;
    }
}

    




